home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 1995 #5 & #6 / Amiga Plus CD - 1995 - No. 5 and 6.iso / pd / daten / ispell / source / amiga / interfaces / gnu-emacs / ispell.el < prev    next >
Lisp/Scheme  |  1992-05-01  |  16KB  |  431 lines
  1. ;;; Spelling correction interface for GNU EMACS using "ispell".
  2.  
  3. ;;; This file is not part of the GNU Emacs distribution (yet).
  4.  
  5. ;; This file is distributed in the hope that it will be useful,
  6. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;; accepts responsibility to anyone for the consequences of using it
  8. ;; or for whether it serves any particular purpose or works at all,
  9. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;; License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute
  13. ;; this file, but only under the conditions described in the
  14. ;; GNU Emacs General Public License.   A copy of this license is
  15. ;; supposed to have been given to you along with GNU Emacs so you
  16. ;; can know your rights and responsibilities.  It should be in a
  17. ;; file named COPYING.  Among other things, the copyright notice
  18. ;; and this notice must be preserved on all copies.
  19.  
  20. (provide 'ispell)
  21.  
  22. ;;; MODIFICATION HISTORY:
  23.  
  24. ;;; Steve Koren   - AmigaDos specific version to use ispell's ARexx port.
  25. ;;;                 needs: ISpell version 3.1ljr with ARexx Server mode.
  26. ;;;                 ispell must be in the AmigaDos search path.   This
  27. ;;;                 version no longer works under Unix.
  28. ;;;
  29. ;;;                 Binds \M-$ to ispell-word
  30. ;;;                 Binds \M-* to ispell-complete-word
  31.  
  32. ;;; Ashwin Ram      ARPA:    Ram-Ashwin@cs.yale.edu
  33. ;;;                 UUCP:    ...!{decvax, linus, seismo}!yale!Ram-Ashwin
  34. ;;;                 BITNET:  Ram@yalecs
  35. ;;; Added variable to control embedded word checking (nice in troff but a pain otherwise).
  36. ;;; 10/26/87.
  37. ;;; Interactive word completion.
  38. ;;; 8/14/87.
  39. ;;; Detex before checking spelling.
  40. ;;; Made options more mnemonic, prompt and error messages better.
  41. ;;; Added highlighting of misspelled word.
  42. ;;; Query-replace all occurrences of misspelled word through buffer.
  43. ;;; Allow customization of personal dictionary.
  44. ;;; Moved temporary file to /tmp.
  45. ;;; Added check for dead ispell process to avoid infinite loop.
  46. ;;; Avoid repeated querying for same word in same buffer.
  47. ;;; 7/6/87.
  48.  
  49. ;;; Walt Buehring
  50. ;;; Texas Instruments - Computer Science Center
  51. ;;; ARPA:  Buehring%TI-CSL@CSNet-Relay
  52. ;;; UUCP:  {smu, texsun, im4u, rice} ! ti-csl ! buehring
  53.  
  54. ;;; ispell-region and associated routines added by
  55. ;;; Perry Smith
  56. ;;; pedz@bobkat
  57. ;;; Tue Jan 13 20:18:02 CST 1987
  58.  
  59. ;;; extensively modified by Mark Davies and Andrew Vignaux
  60. ;;; {mark,andrew}@vuwcomp
  61. ;;; Sun May 10 11:45:04 NZST 1987
  62.  
  63. ;;; Depends on the ispell program snarfed from MIT-PREP in early 1986.
  64.  
  65. ;;; To fully install this, add this file to your GNU lisp directory and 
  66. ;;; compile it with M-X byte-compile-file.  Then add the following to the
  67. ;;; appropriate init file:
  68. ;;; 
  69. ;;; (autoload 'ispell-word "ispell" "Check spelling of word at or before point" t)
  70. ;;; (autoload 'ispell-complete-word "ispell" "Complete word at or before point" t)
  71. ;;; (autoload 'ispell-region "ispell" "Check spelling of every word in the region" t)
  72. ;;; (autoload 'ispell-buffer "ispell" "Check spelling of every word in the buffer" t)
  73. ;;; You might want to bind ispell-word and ispell-complete word to keys.
  74.  
  75. ;;; If run on a heavily loaded system, the initial sleep time in
  76. ;;; ispell-init-process may need to be increased.
  77.  
  78. (define-key global-map "\M-$" 'ispell-word)
  79. (define-key global-map "\M-*" 'ispell-complete-word)
  80.  
  81. (defconst ispell-temp-name " *ispell-temp*"
  82.   "Name of the temporary buffer that 'ispell-region' uses to hold the
  83. filtered region")
  84.  
  85. (defvar ispell-words-have-boundaries t
  86.    "If nil, a misspelled word matches embedded words too.  This is useful in
  87. nroff/troff, where a misspelled word may be hidded (e.g., \fIword\fB), and a
  88. pain otherwise.")
  89.  
  90. (defvar ispell-syntax-table nil)
  91.  
  92. (defvar ispell-temp-words ",")
  93.  
  94. (if (null ispell-syntax-table)
  95.     ;; The following assumes that the standard-syntax-table
  96.     ;; is static.  If you add words with funky characters
  97.     ;; to your dictionary, the following may have to change.
  98.     (progn
  99.       (setq ispell-syntax-table (make-syntax-table))
  100.       ;; Make certain characters word constituents
  101.       ;; (modify-syntax-entry ?' "w   " ispell-syntax-table)
  102.       ;; (modify-syntax-entry ?- "w   " ispell-syntax-table)
  103.       ;; Get rid on existing word syntax on certain characters 
  104.       (modify-syntax-entry ?0 ".   " ispell-syntax-table)
  105.       (modify-syntax-entry ?1 ".   " ispell-syntax-table)
  106.       (modify-syntax-entry ?2 ".   " ispell-syntax-table)
  107.       (modify-syntax-entry ?3 ".   " ispell-syntax-table)
  108.       (modify-syntax-entry ?4 ".   " ispell-syntax-table)
  109.       (modify-syntax-entry ?5 ".   " ispell-syntax-table)
  110.       (modify-syntax-entry ?6 ".   " ispell-syntax-table)
  111.       (modify-syntax-entry ?7 ".   " ispell-syntax-table)
  112.       (modify-syntax-entry ?8 ".   " ispell-syntax-table)
  113.       (modify-syntax-entry ?9 ".   " ispell-syntax-table)
  114.       (modify-syntax-entry ?$ ".   " ispell-syntax-table)
  115.       (modify-syntax-entry ?% ".   " ispell-syntax-table)))
  116.  
  117.  
  118. (defun ispell-word (&optional quietly noclear)
  119.    "Check spelling of word at or before dot.
  120. If word not found in dictionary, display possible corrections in a window 
  121. and let user select."
  122.    (interactive)
  123.    (let* ((current-syntax (syntax-table))
  124.           start end word poss replace)
  125.       (unwind-protect
  126.             (save-excursion
  127.                (set-syntax-table ispell-syntax-table)            ;; Ensure syntax table is reasonable 
  128.                (if (not (looking-at "\\w"))
  129.                    (re-search-backward "\\w" (point-min) 'stay)) ;; Move backward for word if not already on one
  130.                (re-search-backward "\\W" (point-min) 'stay)      ;; Move to start of word
  131.                (or (re-search-forward "\\w+" nil t)              ;; Find start and end of word
  132.                    (error "No word to check."))
  133.                (setq start (match-beginning 0)
  134.                      end (match-end 0)
  135.                      word (buffer-substring start end)))
  136.          (set-syntax-table current-syntax))
  137.       (ispell-init-process)   ;; erases ispell output buffer
  138.       (or noclear (ispell-clear-ignore-list))
  139.  
  140.       (or quietly (message "Checking spelling of %s..." (upcase word)))
  141.  
  142.       (if (string-match (concat "," word ",") ispell-temp-words)
  143.           (setq poss "*")
  144.          
  145.         (setq poss (ispell-parse-output (amiga-ispell-lookup word)))
  146.       )
  147.  
  148.       (cond ((eq poss t)
  149.              (or quietly (message "Checking spelling of %s... correct" (upcase word))))
  150.             ((stringp poss)
  151.              (or quietly (message "Checking spelling of %s... correct (derived from %s)" (upcase word) (upcase poss))))
  152. ;           ((null poss)
  153. ;            (or quietly (message "Checking spelling of %s... not found" (upcase word))))
  154.             (t (setq replace (ispell-choose poss word))
  155.                (if replace
  156.                    (progn
  157.                       (goto-char end)
  158.                       (delete-region start end)
  159.                       (insert-string replace)))))
  160.       poss))
  161.  
  162.  
  163. (defun ispell-choose (choices word)
  164.   "Display possible corrections from list CHOICES.  Return chosen word
  165. if one is chosen, or nil to keep original WORD."
  166.   (unwind-protect 
  167.       (save-window-excursion
  168.     (let ((count 0)
  169.           (line 2)
  170.           (words choices)
  171.           (window-min-height 2)
  172.           char num result)
  173.       (save-excursion
  174.         (set-buffer (get-buffer-create "*Choices*")) (erase-buffer)
  175.         (setq mode-line-format (concat "--  %b (Type number to select replacement for "
  176.                                            (upcase word)
  177.                                            ")  --"))
  178.         (while words
  179.           (if (<= (+ 7 (current-column) (length (car words)))
  180.               (window-width))
  181.           nil
  182.         (insert "\n")
  183.         (setq line (1+ line)))
  184.           (insert "(" (+ count ?0) ") " (car words) "  ")
  185.           (setq words (cdr words)
  186.             count (1+ count)))
  187.             (if (= count 0) (insert "(none)")))
  188.       (overlay-window line)
  189.       (switch-to-buffer "*Choices*")
  190.       (select-window (next-window))
  191.       (while (eq t
  192.              (setq result
  193.                (progn
  194.                  (message "%s: a(dd), c(orrect), r(eplace), space or s(kip) [default], ? (help)" (upcase word)) ; q(uit)
  195.                  (setq char (read-char))
  196.                  (setq num (- char ?0))
  197.                  (cond ((or (= char ? ) (= char ?s))           ; Skip for this invocation
  198.                                     (ispell-ignore-later-occurrences word)
  199.                                     nil)
  200.                    ((= char ?a)                            ; Add to dictionary
  201.                      (amiga-ispell-add word)
  202.                                     (ispell-ignore-later-occurrences word)
  203.                     nil)
  204.                    ((= char ?c)                           ; Assume correct but don't add to dict
  205.                                     (ispell-ignore-later-occurrences word)
  206.                     nil)
  207.                    ((= char ?r)                           ; Query replace
  208.                                     (ispell-ignore-later-occurrences word)
  209.                                     (read-string (format "Replacement for %s: " (upcase word)) nil))
  210.                    ((and (>= num 0) (< num count))
  211.                                     (ispell-ignore-later-occurrences word)
  212.                                     (nth num choices))
  213.                    ((= char ?\C-r)                        ; Note: does not reset syntax table
  214.                     (save-excursion (recursive-edit)) t)  ; Dangerous
  215. ;                   ((= char ?\C-z)
  216. ;                    (suspend-emacs) t)
  217.                    ((or (= char help-char) (= char ?\?))
  218.                                     (message "a(dd to dict), c(orrect for this session), r(eplace with your word), or number of replacement")
  219.                     (sit-for 3) t)
  220.                    (t (ding) t))))))
  221.       result))
  222.     ;; Protected forms...
  223.     (bury-buffer "*Choices*")))
  224.  
  225. (defun ispell-clear-ignore-list ()
  226.   (setq ispell-temp-words ",")
  227. )
  228.  
  229. (defun ispell-ignore-later-occurrences (word)
  230.  
  231.   (if (not (string-match (concat "," word ",") ispell-temp-words))
  232.       (setq ispell-temp-words
  233.             (concat ispell-temp-words word ",")))
  234. )
  235.  
  236. (defun overlay-window (height)
  237.   "Create a (usually small) window with HEIGHT lines and avoid
  238. recentering."
  239.   (save-excursion
  240.     (let ((oldot (save-excursion (beginning-of-line) (dot)))
  241.       (top (save-excursion (move-to-window-line height) (dot)))
  242.       newin)
  243.       (if (< oldot top) (setq top oldot))
  244.       (setq newin (split-window-vertically height))
  245.       (set-window-start newin top))))
  246.  
  247.  
  248. (defun ispell-parse-output (output)
  249. "Parse the OUTPUT string of 'ispell' and return either t for an exact
  250. match, a string containing the root word for a match via suffix
  251. removal, a list of possible correct spellings, or nil for a complete
  252. miss."
  253.   (cond
  254.    ((string= output "*\n") t)
  255.    ((string= output "#\n") nil)
  256.    ((string= (substring output 0 1) "+")
  257.     (substring output 2))
  258.    (t
  259.     (let ((choice-list '()))
  260.       (while (not (string= output ""))
  261.     (let* ((start (string-match "[A-z]" output))
  262.            (end (string-match " \\|$" output start)))
  263.       (if start
  264.           (setq choice-list (cons (substring output start end)
  265.                       choice-list)))
  266.       (setq output (substring output (1+ end)))))
  267.       choice-list))))
  268.  
  269.  
  270. (defun ispell-init-process ()
  271.    "Check status of 'ispell' process and start if necessary."
  272.  
  273.    (if (not (boundp 'amiga-ispell-initialized))
  274.  
  275.        (progn
  276.          (message "starting ispell...")
  277.          (amiga-arexx-do-command
  278.           (concat
  279.  
  280. "\"if pos('IRexxSpell', (show(ports))) = 0 then do;
  281. address command 'run ispell -r <nil: >nil:';
  282. address command waitforport 'IRexxSpell';
  283. end\"") nil
  284.  
  285.          )
  286.          (setq amiga-ispell-initialized t)
  287.        )
  288.    )
  289. )
  290.  
  291. (defvar ispell-filter-hook "tr"
  292.   "Filter to pass a region through before sending it to ispell.
  293. Must produce output one word per line.  Typically this is set to tr,
  294. deroff, detex, etc.")
  295. (make-variable-buffer-local 'ispell-filter-hook)
  296.  
  297. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  298. ;; OLD CODE:
  299. ;;(defvar ispell-filter-hook-args '("-cs" "A-Za-z" "\012")
  300. ;;  "Argument LIST to pass to ispell-filter-hook")
  301. ;;(make-variable-buffer-local 'ispell-filter-hook-args)
  302. ;;
  303. ;; NEW CODE:
  304. (defvar ispell-filter-hook-args
  305.   (if (equal system-type 'hpux)
  306.       '("-cs" "[A-Z][a-z]" "[\012*]")
  307.       '("-cs" "A-Za-z" "\n")
  308.   )
  309.   "Argument LIST to pass to ispell-filter-hook"
  310. )
  311. (make-variable-buffer-local 'ispell-filter-hook-args)
  312.  
  313.  
  314. (defun ispell-region (start end)
  315.    "Check a region for spelling errors interactively.  The variable
  316. which should be buffer or mode specific ispell-filter-hook is called
  317. to filter out text processing commands."
  318.    (interactive "r")
  319.    (let ((current-syntax (syntax-table)))
  320.      (ispell-clear-ignore-list)
  321.      (ispell-init-process)
  322.  
  323.      (unwind-protect
  324.          (save-excursion
  325.            (save-restriction
  326.              (message "Prefrobnicating...")
  327.              (narrow-to-region start end)
  328.              (sit-for 0)
  329.              (set-syntax-table ispell-syntax-table)
  330.              
  331.              (goto-char start)
  332.  
  333.              (message "Looking for a misspelled word...")
  334.  
  335.              (while (forward-word 1)
  336.                (if (equal (ispell-word t t) t)
  337.                    (message "Looking for a misspelled word...")
  338.                )
  339.              )
  340.                
  341.              (sit-for 0)
  342.  
  343.              (message "Done.")
  344.  
  345.              (set-syntax-table current-syntax))))))
  346.  
  347. (defun ispell-buffer () 
  348.   "Check the current buffer for spelling errors interactively.  The variable
  349. which should be buffer or mode specific ispell-filter-hook is called to
  350. filter out text processing commands."
  351.   (interactive)
  352.   (ispell-region (point-min) (point-max)))
  353.  
  354.  
  355. ; In case you don't have this, uncomment the following:
  356.  
  357. ; (defun highlight-region (p1 p2)
  358. ;    "Highlight the current region."
  359. ;    (interactive "r")
  360. ;    (let ((s (buffer-substring p1 p2))
  361. ;          (inverse-video t))
  362. ;       (delete-region p1 p2)
  363. ;       (sit-for 0)
  364. ;       (insert s)
  365. ;       (sit-for 0)))
  366.  
  367. ; (defun unhighlight-region (p1 p2)
  368. ;    "Unhighlight the current region."
  369. ;    (interactive "r")
  370. ;    (let ((s (buffer-substring p1 p2))
  371. ;          (inverse-video nil))
  372. ;       (delete-region p1 p2)
  373. ;       (sit-for 0)
  374. ;       (insert s)
  375. ;       (sit-for 0)))
  376.  
  377.  
  378. ;; Interactive word completion.
  379. ;; Some code and many ideas tweaked from Peterson's spell-dict.el.
  380. ;; Ashwin Ram <Ram@yale>, 8/14/87.
  381.  
  382. (defun ispell-complete-word ()
  383.    "Look up word before point in dictionary (see the variable
  384. ispell-words-file) and try to complete it.  If in the middle of a word,
  385. replace the entire word."
  386.    (interactive)
  387.    (let* ((current-word (buffer-substring (save-excursion (backward-word 1) (point))
  388.                                           (point)))
  389.           (in-word (looking-at "\\w"))
  390.           (words (if (> (length current-word) 2)
  391.                      (amiga-ispell-lookup
  392.                       (concat current-word ".*") t)
  393.                    ""))
  394.  
  395.           (possibilities (if (> (length words) 0)
  396.                              (ispell-parse-output words)
  397.                                 '()))
  398.  
  399.      (replacement (ispell-choose possibilities current-word)))
  400.    (cond (replacement
  401.           (if in-word (kill-word 1))        ;; Replace the whole word.
  402.           (search-backward current-word)
  403.           (replace-match (downcase replacement))))))   ;; To preserve capitalization etc.
  404.  
  405.  
  406. ;;; **************************************************************************
  407. ;;; --- Amiga specific extension to ispell to use ispell's ARexx port --------
  408. ;;; **************************************************************************
  409.  
  410. (defun amiga-ispell-lookup (word &optional regexp)
  411.   "lookup word in dictionary using arexx - interal ispell fn"
  412.   (amiga-arexx-do-command
  413.    (concat
  414.  
  415.     "\"options results;
  416.        address 'IRexxSpell' " (if regexp "lookup" "check") " '"
  417.     word
  418.     "' ;address EMACS1 '(setq arexx-result '||d2c(34)||result||d2c(34)||')'\""
  419.     )
  420.    nil)
  421.  
  422.   (concat arexx-result "\n")
  423. )
  424.  
  425. (defun amiga-ispell-add (word)
  426.   "add word to dictionary using arexx - interal ispell fn"
  427.   (amiga-arexx-do-command
  428.    (concat "\"address 'IRexxSpell' 'add' '" word "'")
  429.    nil)
  430. )
  431.